Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue64/WBroker/main.pas

Pascal/Delphi Source File | 2000-10-01 | 9.8 KB | 334 lines

unit Main;
{ $M 40960, 8192}

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, FileCtrl, StdCtrls, Buttons, Outline, ExtCtrls, Tabs,
  Grids, NewParse, HTTPApp;

type
  TCVCSMain = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    SpeedButton2: TSpeedButton;
    SpeedButton1: TSpeedButton;
    SaveDialog1: TSaveDialog;
    CheckBox1: TCheckBox;
    Label4: TLabel;
    ComboBox1: TComboBox;
    DriveComboBox1: TDriveComboBox;
    Label1: TLabel;
    Label3: TLabel;
    ListBox1: TListBox;
    Outline1: TOutline;
    DirectoryListBox1: TDirectoryListBox;
    FileListBox1: TFileListBox;
    Label2: TLabel;
    PageProducer1: TPageProducer;
    procedure FileListBox1DblClick(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure PageProducer1HTMLTag(Sender: TObject; Tag: TTag;
      const TagString: String; TagParams: TStrings;
      var ReplaceText: String);
  private
    { Private declarations }
    ExcludeList: TStringList;
    procedure BuildList(FName: string; var Level: integer);
    function Parse(var ParseStr: string): string;
    function GetUsesClause(FName: string): string;
    procedure FindUnit(var FName: string);
  public
    { Public declarations }
  end;

var
  CVCSMain: TCVCSMain;

implementation

{$R *.DFM}

{ GetUsesClause - routine to extract the uses clause from a unit }
function TCVCSMain.GetUsesClause(FName: string): string;
var
  AStream: TFileStream;
  Parser: TCustomParser;
  BeginCopy,
  FoundUses,
  IsComment: boolean;
  S: string;
begin
  { initiallize variables }
  Result := '';
  BeginCopy := false;
  FoundUses := false;
  IsComment := false;
  try
    { open FileStream(FName) }
    AStream := TFileStream.Create(FName, fmOpenRead);
    { create unit parser }
    Parser := TEnhPasParser.Create(AStream);
    try
      with Parser do
        while Token <> toEOF do
        begin
          S := TokenString;
          case Token of
            toSymbol: begin
                if (TokenString = 'implementation') and not IsComment then
                  FoundUses := true;
                if (TokenString = 'uses') and not IsComment then
                begin
                  BeginCopy := true;
                  S := '';
                end;
              end;
            ';': begin
                if FoundUses then Exit;
                if BeginCopy then
                begin
                  AppendStr(Result, ',');
                  BeginCopy := false;
                end;
              end;
            '{': begin
                S := '';
                IsComment := true;
              end;
            '}': begin
                S := '';
                IsComment := false;
              end;
          end;
          if BeginCopy and not IsComment then AppendStr(Result, S);
          NextToken;
        end;
    finally
      Parser.Free;
      AStream.Free;
    end;
  except
    { on file open error return empty string }
    on EFOpenError do Result := '';
  end;
end;

{ Parse - routine to parse the uses clause }
function TCVCSMain.Parse(var ParseStr: string): string;
var
  Len: integer;
begin
  Result := '';
  if Length(ParseStr) > 0 then { if there is something to parse... }
  begin
    repeat
      if Pos(',', ParseStr) <> 0 then  { if there is a comma... }
      begin
        { copy up to it }
        Len := Pos(',', ParseStr);
        Result := System.Copy(ParseStr, 1, Len-1);
      end else
      begin
        { else copy all remaining string }
        Len := Length(ParseStr);
        Result := System.Copy(ParseStr, 1, Len);
      end;
      { delete what we copied }
      System.Delete(ParseStr, 1, Len);
      { if we have a valid unit name... }
      if IsValidIdent(Result) then Result := Result+'.pas' { add .pas extension }
      else Result := ''; { else return empty string }
    { ...until there is a unit NOT in the exclude list }
    until (ExcludeList.IndexOf(Result) < 0);
  end;
end;

procedure TCVCSMain.FindUnit(var FName: string);
var
  FN, TempStr: string;
begin
  FN := FName; { set FN equal to FName }
  { perform the search }
  TempStr := FileSearch(FN, ComboBox1.Text);
  { if successful change FName }
  if TempStr <> '' then FName := ExpandFileName(TempStr);
end;

{ BuildList - recursive routine to ''walk'' the units tree }
procedure TCVCSMain.BuildList(FName: string; var Level: integer);
var
  NextFile, Remaining: string;
  Idx: integer;
begin
  { find the file on the path }
  FindUnit(FName);
  { add node for file }
  Idx := Outline1.Add(Outline1.SelectedItem, FName);
  Outline1.Items[Idx].Level := Level;
  { add file to exclude list to avoid infinite
    recursion from circular unit references }
  ExcludeList.Add(ExtractFileName(FName));
  { get the uses clause from FName }
  Remaining := GetUsesClause(FName);
  { parse the units clause }
  NextFile := Parse(Remaining);
  while NextFile <> '' do { if NextFile is not empty... }
  begin
    { Inc tree level }
    Inc(Level);
    { recurse with first dependant file }
    BuildList(NextFile, Level);
    { find next dependant file }
    NextFile := Parse(Remaining);
    { Dec tree level }
    Dec(Level);
  end;
end;

procedure TCVCSMain.FileListBox1DblClick(Sender: TObject);
var
  L: integer;
begin
  L := 1;
  Screen.Cursor := crHourglass;
  try
    { clear the exclude list }
    ExcludeList.Clear;
    { if user want''s to use the exclude list... }
    if CheckBox1.Checked then ExcludeList.Assign(ListBox1.Items);
    { call BuildList to fill the Outline }
    BuildList(FileListBox1.Items[FileListBox1.ItemIndex], L);
    { Expand the Outline }
    Outline1.FullExpand;
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TCVCSMain.SpeedButton2Click(Sender: TObject);
begin
  { clear the Outline }
  Outline1.Clear;
end;

procedure TCVCSMain.FormCreate(Sender: TObject);
begin
  { create the exclude list }
  ExcludeList := TStringList.Create;
  ExcludeList.Sorted := true;
  ExcludeList.Duplicates := dupIgnore;
  { add possible exclude items to the list box }
  ListBox1.Items.Add ('Windows.pas');
  ListBox1.Items.Add ('WinTypes.pas');
  ListBox1.Items.Add ('WinProcs.pas');
  ListBox1.Items.Add ('SysUtils.pas');
  ListBox1.Items.Add ('System.pas');
  ListBox1.Items.Add ('Classes.pas');
  ListBox1.Items.Add ('ClipBrd.pas');
  ListBox1.Items.Add ('Messages.pas');
  ListBox1.Items.Add ('Graphics.pas');
  ListBox1.Items.Add ('Controls.pas');
  ListBox1.Items.Add ('Consts.pas');
  ListBox1.Items.Add ('ComCtrls.pas');
  ListBox1.Items.Add ('Forms.pas');
  ListBox1.Items.Add ('Dialogs.pas');
  ListBox1.Items.Add ('Menus.pas');
  ListBox1.Items.Add ('Mask.pas');
  ListBox1.Items.Add ('Outline.pas');
  ListBox1.Items.Add ('StdCtrls.pas');
  ListBox1.Items.Add ('ExtCtrls.pas');
  ListBox1.Items.Add ('FileCtrl.pas');
  ListBox1.Items.Add ('Buttons.pas');
  ListBox1.Items.Add ('Tabs.pas');
  ListBox1.Items.Add ('TabNotBk.pas');
  ListBox1.Items.Add ('HTTPApp.pas');
  ListBox1.Items.Add ('Grids.pas');
  ListBox1.Items.Add ('Printers.pas');
  ListBox1.Items.Add ('DDEMan.pas');
  ListBox1.Items.Add ('MPlayer.pas');
  ListBox1.Items.Add ('TOCtrl.pas');
  ListBox1.Items.Add ('IniFiles.pas');
  ListBox1.Items.Add ('DsgnIntf.pas');
  ListBox1.Items.Add ('ToolIntf.pas');
  ListBox1.Items.Add ('DB.pas');
  ListBox1.Items.Add ('DBTables.pas');
  ListBox1.Items.Add ('DBLookup.pas');
  ListBox1.Items.Add ('DBGrids.pas');
  ListBox1.Items.Add ('DBiTypes.pas');
  ListBox1.Items.Add ('DBiProcs.pas');
  ListBox1.Items.Add ('DBCtrls.pas');
  ListBox1.Items.Add ('DBiErrs.pas');
  { assign ListBox1.Items to exclude list
    since this is the default }
  ExcludeList.Assign(ListBox1.Items);
end;

procedure TCVCSMain.FormDestroy(Sender: TObject);
begin
  { free the exclude list }
  ExcludeList.Free;
end;

procedure TCVCSMain.SpeedButton1Click(Sender: TObject);
begin
  with TStringList.Create do
  try
    if SaveDialog1.Execute then
    begin
      Text := PageProducer1.Content;
      SaveToFile(SaveDialog1.FileName);
    end;
  finally
    Free;
  end;
end;

procedure TCVCSMain.PageProducer1HTMLTag(Sender: TObject; Tag: TTag;
  const TagString: String; TagParams: TStrings; var ReplaceText: String);
var
  i, j: integer;
  CurLev: Cardinal;
begin
  CurLev := 0;

  if (CompareText(TagString, 'Title') = 0) or (CompareText(TagString, 'Heading') = 0) then
    ReplaceText := 'Packing List';

  if (CompareText(TagString, 'Root') = 0) then
    ReplaceText := Format('%s', [Outline1.Items[1].Text]);

  if CompareText(TagString, 'List') = 0 then
  begin
    for i := 0 to Outline1.Lines.Count-1 do
    begin
      { if level goes up... }
      if Outline1.Items[i+1].Level > CurLev then
      begin
        ReplaceText := ReplaceText + '<UL>'; { increase indent }
        Inc(CurLev);      { increase CurLev }
      end;
      { if level goes down... }
      if Outline1.Items[i+1].Level < CurLev then
        { for CurLev down to the new level }
        for j := CurLev downto Outline1.Items[i+1].Level+1 do
        begin
          ReplaceText := ReplaceText + '</UL>'; { close list level }
          Dec(CurLev);  { decrease CurLev }
        end;
      ReplaceText := ReplaceText + #13#10;
      ReplaceText := ReplaceText + '<LI>'+Outline1.Items[i+1].Text; { write out the actual text }
    end;
    for j := CurLev downto 0 do ReplaceText := ReplaceText + '</UL>'; { close all list levels }
    { Html footer }
    ReplaceText := ReplaceText + '<HR>'#13#10'Generated by <b>PackList</b> from';
    ReplaceText := ReplaceText + ' HomeGrown Software, by Paul Warren.';
  end;
end;

end.